{***************************************************************************}
{                                                                           }
{        MLC fork of DUnitX                                                 }
{                                                                           }
{        Copyright (C) 2014 National Australia Bank Limited ACN 004 044 937 }
{                                                                           }
{        Author: Sean B. Durkin                                             }
{        sean@seanbdurkin.id.au                                             }
{                                                                           }
{                                                                           }
{***************************************************************************}
{                                                                           }
{  Licensed under the Apache License, Version 2.0 (the "License");          }
{  you may not use this file except in compliance with the License.         }
{  You may obtain a copy of the License at                                  }
{                                                                           }
{      http://www.apache.org/licenses/LICENSE-2.0                           }
{                                                                           }
{  Unless required by applicable law or agreed to in writing, software      }
{  distributed under the License is distributed on an "AS IS" BASIS,        }
{  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. }
{  See the License for the specific language governing permissions and      }
{  limitations under the License.                                           }
{                                                                           }
{***************************************************************************}
unit MLC.MemoryMonitor.Solution;
interface
uses MLC.MemoryMonitor, SBD.ServiceProvider, Classes;

type
TMemoryMonitor = class( TInterfacedPersistent, IMemoryMonitor)
  private
    FMS1, FMS2: TMemoryManagerState;
    FLeakageOffset: int64;
    FIsMonitoring: boolean;
    procedure Clear;
    procedure HeapMonitoring_ON;
    procedure HeapMonitoring_OFF;
    function  Leakage: int64;
    constructor PrivateCreate;
  public
    destructor Destroy; override;
  end;


procedure RegisterServices( const Provider: IServiceProvider);
// Provides:
//   GUID                  config        ArrayId                          Mode
//   ----------------------------------------------------------------------------------
//   IMemoryMonitor        ''            'System.TMemoryManagerState'     Competitive
//
// Requires:
//   GUID                  config        ArrayId                          Mode
//   ----------------------------------------------------------------------------------
//   None


implementation








uses SysUtils;
var
  Instance: TMemoryMonitor = nil;




constructor TMemoryMonitor.PrivateCreate;
begin
if assigned( Instance) then
  raise Exception.Create( 'DUnitX internal error');
Instance := self;
end;

destructor TMemoryMonitor.Destroy;
begin
Instance := nil;
inherited
end;


procedure RegisterServices( const Provider: IServiceProvider);
begin
Provider.RegisterFlyweightService( IMemoryMonitor,
  function( const Config: string; const ServiceProvider: IServiceProvider): IInterface
    begin
    if not assigned( Instance) then
      TMemoryMonitor.PrivateCreate;
    result := Instance as IMemoryMonitor
    end,
  '', 'System.TMemoryManagerState')
end;

{ TMemoryMonitor }

procedure TMemoryMonitor.Clear;
begin
FIsMonitoring := False;
FLeakageOffset := 0
end;


procedure TMemoryMonitor.HeapMonitoring_OFF;
var
  i: Integer;
  SMBSize1, SMBSize2: uint64;
begin
if not FIsMonitoring then exit;
SMBSize1 := 0;
SMBSize2 := 0;
GetMemoryManagerState( FMS2);
for i := 0 to NumSmallBlockTypes - 1 do // Iterate through the blocks
  begin
  with FMS1.SmallBlockTypeStates[i] do
    Inc( SMBSize1, (InternalBlockSize * AllocatedBlockCount));
  with FMS2.SmallBlockTypeStates[i] do
    Inc( SMBSize2, (InternalBlockSize * AllocatedBlockCount))
  end;
FLeakageOffset := FLeakageOffset +
                  int64( SMBSize2 - SMBSize1) +
                 (int64( FMS2.TotalAllocatedMediumBlockSize) - int64( FMS1.TotalAllocatedMediumBlockSize)) +
                 (int64( FMS2.TotalAllocatedLargeBlockSize ) - int64( FMS1.TotalAllocatedLargeBlockSize ));
FIsMonitoring := False
end;

procedure TMemoryMonitor.HeapMonitoring_ON;
begin
if FIsMonitoring then exit;
GetMemoryManagerState( FMS1);
FIsMonitoring := True
end;

function TMemoryMonitor.Leakage: int64;
begin
result := FLeakageOffset
end;


initialization
Instance := nil;

finalization
Instance.Free

end.
